home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1993…stman Always Clicks Twice / ADC Developer CD (1993-01) (''The Postman Always Clicks Twice'')_iso / Dev.CD 199301.iso / Development Platforms / LISP Related / LISP Goodies / rcs.lisp < prev    next >
Encoding:
Text File  |  1992-09-02  |  20.7 KB  |  440 lines  |  [TEXT/CCL2]
  1. ;;; RCS.LISP (Simple Revision Control System)
  2. ;;; Version 1.1, Jan. '92
  3. ;;; Functions for managing the editing of project code by multiple people.
  4. ;;; Hacked by David Neves - neves@ils.nwu.edu
  5. ;;;
  6. ;;; Changes:
  7. ;;; neves  (1/21)   Make a variable to hold folder of server volume on server machine
  8. ;;; neves  (1/7/92) Server now has a separate working directory.
  9. ;;; neves  (12/23)  Updated to MACL 2.0
  10. ;;; neves  (1/23/91)If a copy to the server is cancelled the write date on the server won't be changed.
  11. ;;;
  12. ;;; Documentation:
  13. ;;;   On any large project there is a danger of 2 people editing the same file at the same time.
  14. ;;; Most likely one person's changes will be lost.  This software allows someone to "lock" a
  15. ;;; file so that no one else can edit it.  When the user is finished editing the file they
  16. ;;; can "unlock" the file so that others can edit it.
  17. ;;;
  18. ;;; User choices from the "lockfile" menu:
  19. ;;;   - Lock a file.  This brings up a dialog so that the user can choose a file to lock.  If
  20. ;;;     the file is already locked then the user gets an error message.  Locking a file
  21. ;;;     copies the file from the server to the local hard disk.  Then the name of the locked
  22. ;;;     file is stored in a special file ("locked-file-list") on the server.
  23. ;;;   - Unlock a file and copy to server.  This brings up a dialog with all your locked files.  
  24. ;;;     Select 1 or more files (with shift-click) to unlock.  The files are copied back to the 
  25. ;;;     server and their names are deleted from "locked-file-list".
  26. ;;;   - Unlock a file, but don't copy to server.  This is like the choice above but the files
  27. ;;;     are not copied to the server.  Useful when the user changes his/her mind about making
  28. ;;;     the changes permanent.
  29. ;;;   - Copy a newly created file to the server.  The user has just created a file on his/her
  30. ;;;     hard disk.  To move it to the server choose this.
  31. ;;;   - Copy logged files to local disk.  This is a quick hack that allows the user to copy
  32. ;;;     files that others have changed.  The user is shown the list of changed files (in the
  33. ;;;     logfile) and can select 1 or many (by shift clicking) files to copy over to their disk.
  34. ;;;   - Show all locked files.  Show a list of all the locked files, along with who locked them.
  35. ;;;
  36. ;;; Hardware needed:
  37. ;;;   Each user needs a Macintosh with access to an Appleshare network.
  38. ;;;   You need a server machine that can be mounted from other Macs.
  39. ;;;
  40. ;;; Software needed:
  41. ;;;   System 7.0 (or greater) & MACL 2.0 (or greater)
  42. ;;;
  43. ;;; To install:
  44. ;;;    Simply load this file.  The LockFile menu choice will install itself.  If you want to
  45. ;;; save this file within an application and one of your users uses the server machine
  46. ;;; then have (init-rcs) executed when your application is started up.
  47. ;;;;;;
  48. ;;; Known misfeatures:
  49. ;;;   I should write some code that allows one to automatically update their
  50. ;;;  directory.
  51. ;;;
  52. ;;; Known bugs:
  53. ;;;   I suppose it is possible for 2 people to (almost) simultaneously unlock the same file.  We
  54. ;;;  have never had it happen to us.
  55. ;;;   I am not sure what will happen if someone on the server machine locks a file
  56. ;;;  outside of the shared directory.
  57. ;;;
  58. ;;; Changes you have to make:
  59. ;;;   The only changes you should need to make for your project are to the defparameters below.
  60. ;;; Because a person on a server machine cannot mount their own machine
  61. ;;; I have a bunch of special case code that allows one to use this software
  62. ;;; on a server machine.
  63.  
  64. (in-package :ccl)
  65.  
  66. ;;; ------------------------------------------------------------------------------------------------
  67. ;;; change the following strings for your project.  Only the 1st 3 are required to be changed.
  68. (defparameter *server-name* "feist")  ;<used only if someone is using the server machine>
  69.                                       ;put fileserver name here.  This is the chooser name.
  70. (defparameter *home-directory* "ccl;physics:")       ;Local home directory where the project files are kept.
  71.                                                      ;This is where a file ends up when locked and copied.
  72. (defparameter *outsider-server-volume* "physics (shared):")   
  73.                                                               ;Server volume where the project files are kept
  74.                                                               ;If someone is running on the server machine we
  75.                                                               ;assume this is in ccl; (see below)
  76. (defparameter *folder-of-outsider-server-volume-on-server* "ccl;")
  77.                                                               ;<used only if someone is using the server machine>      
  78.                                                               ;location of *outsider-server-volume on server machine
  79.                                                               ;e.g. on server machine -- ccl;physics (shared):
  80. (defparameter *filename-locked-file-list-file* "locked-file-list") ;File for list of locked files
  81. (defparameter *filename-log-file* "logfile")                  ;File for documentation on changes made to files
  82. ;;; ------------------------------------------------------------------------------------------------
  83. (defvar *locked-file-list-file*) ; full pathname of locked-file-list-file
  84. (defvar *log-file*)              ; full pathname of log file
  85. (defvar *server-servers-volume* nil)           ;server access to server volume
  86. (defvar *server-volume*)         ; The server machine relative to the user.
  87. (defvar *locked-file-list*)      ; temporary list holding the contents of locked-file-list-file
  88. (defvar *rcs-menu*)              ; lock file menu
  89.  
  90. (defun on-server-p nil (equal (machine-instance) *server-name*))
  91.  
  92. (defmacro concat (&rest strings)
  93.   `(concatenate 'string ,@strings))
  94.  
  95. ;;; init-rcs is called automatically at the end of this file
  96. (defun init-rcs nil
  97.   (setq *home-directory* (mac-namestring *home-directory*))
  98.   (setq *server-servers-volume* (mac-namestring 
  99.                                  (concat *folder-of-outsider-server-volume-on-server* 
  100.                                          *outsider-server-volume*)))
  101.   (if (on-server-p)
  102.     (setf (logical-pathname-translations 
  103.           ;; take out the colon at the end of *outsider-server-volume*
  104.           (subseq *outsider-server-volume* 0 (1- (length *outsider-server-volume*))))
  105.           ;; copied right out of steele without understanding it...
  106.           `(("**;*.*.*" ,(concat *server-servers-volume* "**")))))
  107.   (setq *server-volume* *outsider-server-volume*)
  108.   (setq *locked-file-list-file* (concatenate 'string *server-volume* *filename-locked-file-list-file*))
  109.   (setq *log-file* (concatenate 'string *server-volume* *filename-log-file*))
  110.   
  111.   (if (find-menu "LockFile") (menu-deinstall *rcs-menu*))
  112.   (setq *rcs-menu* (make-instance 'menu :menu-title "LockFile"))
  113.   (add-menu-items *rcs-menu*
  114.                    (make-instance 'menu-item
  115.                           :menu-item-title "Lock a project file and copy to local disk"
  116.                           :menu-item-action #'lock-project-file)
  117.                    (make-instance 'menu-item
  118.                           :menu-item-title "Unlock project file and copy new version to server"
  119.                           :menu-item-action #'unlock-project-file)
  120.                    (make-instance 'menu-item
  121.                           :menu-item-title "Unlock project file but don't copy new version to server"
  122.                           :menu-item-action #'unlock-file-dont-copy)
  123.                    (make-instance 'menu-item
  124.                           :menu-item-title "Copy newly created file to server."
  125.                           :menu-item-action #'copy-new-file-to-server)
  126.                    (make-instance 'menu-item
  127.                           :menu-item-title "Copy logged files to local disk."
  128.                           :menu-item-action #'copy-logfiles-to-local-disk)
  129.                    (make-instance 'menu-item
  130.                           :menu-item-title "Show all locked files"
  131.                           :menu-item-action #'find-all-locked-files)
  132.                    )
  133.   (menu-install *rcs-menu*)
  134.   
  135.   (load-locked-file-list)
  136.   
  137.   
  138.   )
  139.  
  140. ;;; This is what users will call
  141. #|
  142.  
  143. ;;; This is what programmers will call
  144. (defun copy-experimental-project (&optional (purge nil))
  145.   (when (eq t (catch-cancel
  146.                 (y-or-n-dialog "Are you sure you want to copy the experimental directory to the local disk?")))
  147.   (show-listener)
  148.   (format t "~%Please wait as I copy the project directory to the local disk...~%")
  149.   (copy-directory *experimental-project-directory* *home-directory* t purge)
  150.   (format t "DONE!")
  151.   ))
  152. |#
  153.  
  154. (defun server-to-logical-server-name (file)
  155.   (concat *server-volume*
  156.           (strip-left (namestring (translate-logical-pathname *server-volume*))
  157.                       file)))
  158.  
  159. ;;; lock a file on the experimental directory
  160. (defun lock-project-file nil
  161.   (let (longfilename
  162.         tofile
  163.         tofileyounger
  164.         (default-choose-directory (choose-file-default-directory))
  165.         )
  166.     (when (string-equal (machine-instance) "")
  167.       (message-dialog "Aborted because you have not named your Mac.  Please name your computer in Sharing Setup in Control Panels.")
  168.       (return-from lock-project-file))
  169.     (setq longfilename 
  170.           (catch-cancel 
  171.             (choose-file-dialog :directory *server-volume*
  172.                                 )))
  173.     (set-choose-file-default-directory default-choose-directory)
  174.     (when (neq longfilename :cancel)
  175.       (setq longfilename (namestring longfilename))
  176.       (setq longfilename (server-to-logical-server-name longfilename))
  177.       (when (is-locked-filep longfilename)
  178.         (message-dialog (concat longfilename " is already locked.  Aborting request..."))
  179.         (return-from lock-project-file))
  180.       (setq tofile (server-to-home-name longfilename))
  181.       (setq tofileyounger (is-youngerp tofile longfilename))
  182.       (when (or (not tofileyounger)
  183.                 (and tofileyounger
  184.                      (eq t (catch-cancel (y-or-n-dialog
  185.                                           "The file on the local disk is younger than the one on the server.  Should I still copy it?")))))
  186.         (if (probe-file tofile) (unlock-file tofile))
  187.         (copy-file longfilename tofile
  188.                    :if-exists :overwrite)
  189.         (lock-and-print longfilename tofile)
  190.        ))))
  191.  
  192. (defun lock-and-print (serverfilename homefilename)
  193.   (let (shortfilename)
  194.     (setq shortfilename (file-namestring serverfilename))
  195.     (update-locked-file-list serverfilename :add)
  196.     (if (y-or-n-dialog  
  197.          (concat shortfilename " has been copied to your disk and is locked.  To edit the file click on EDIT, otherwise click on OK.")
  198.          :yes-text "EDIT" :no-text "OK" :cancel-text nil)
  199.       (ed homefilename))))
  200.  
  201. (defun is-youngerp (file1 file2)
  202.   (and (probe-file file1) (probe-file file2) (> (file-write-date file1) (file-write-date file2))))
  203.  
  204. ;;; format of locked-file-list is ((filename . person) (filename . person) ...)
  205.  
  206. (defun is-locked-filep (filename)
  207.   (load-locked-file-list)
  208.   (assoc filename *locked-file-list* 
  209.          :test #'string-equal))
  210.  
  211. (defun load-locked-file-list nil
  212.   (if (null (probe-file *locked-file-list-file*))
  213.     (with-open-file (stream *locked-file-list-file* :direction :output)
  214.       (print nil stream)))
  215.   (setq *locked-file-list*
  216.           (with-open-file  (stream *locked-file-list-file* :direction :input)
  217.             (read stream))))
  218.  
  219. (defun save-locked-file-list nil
  220.   (let ((tempfilename (concat *locked-file-list-file* "temp")))
  221.     (with-open-file (stream tempfilename :direction :output :if-exists :supersede)
  222.       (print *locked-file-list* stream))
  223.     (rename-file tempfilename *locked-file-list-file* :if-exists :overwrite)))
  224.  
  225. (defun username nil (machine-instance))
  226.  
  227. (defun make-pair (&key filename person)
  228.   (cons filename person))
  229. (defun get-person (pair)
  230.   (rest pair))
  231. (defun get-filename (pair)
  232.   (first pair))
  233.  
  234. ;;; ------------------------------------------------------------------------------------
  235. (defun unlock-project-file (&optional (dontcopyflag nil))
  236.    (let ((username (machine-instance))
  237.          (homefilename)
  238.          (serverfilenames))
  239.     (when (eql username "")
  240.       (message-dialog "Aborted because you have not named your Mac.  Please name your computer in Sharing Setup in Control Panels.")
  241.       (return-from unlock-project-file))
  242.      (setq serverfilenames 
  243.            (catch-cancel 
  244.             (select-item-from-list (find-my-locked-files) :selection-type :disjoint)))
  245.      (when (neq serverfilenames :cancel)
  246.       (dolist (serverfilename serverfilenames)
  247.         ;; doncopyflag means unlock the file but don't copy your version to the project directory
  248.         (when (null dontcopyflag)
  249.           (setq homefilename (server-to-home-name serverfilename))
  250.           (if (probe-file homefilename)
  251.             (copy-to-server-and-update-logfile homefilename serverfilename)
  252.             (format t "You do not have ~a to copy to the project directory~%" homefilename))
  253.         )
  254.         (update-locked-file-list serverfilename :delete)
  255.         ))))
  256.  
  257. ;;; Given a name on the server, construct the corresponding name on the home directory.
  258. (defun server-to-home-name (filename)
  259.   (concat *home-directory* 
  260.           (strip-left *server-volume* (namestring filename))))
  261.  
  262. ;;; Given a name on the home directory, construct a name for the server
  263. (defun home-to-server-name (filename) 
  264.   (concat *server-volume*
  265.           (strip-left *home-directory*  (namestring filename))))
  266.  
  267. (defun copy-to-server-and-update-logfile (homefilename serverfilename)
  268.   (if (or (null (probe-file serverfilename))
  269.           (>= (file-write-date homefilename) (file-write-date serverfilename))
  270.           (eq t (catch-cancel (y-or-n-dialog
  271.                                "The file on the local disk is older than the one on the server.  Should I still copy it?"))))
  272.     (progn
  273.       (copy-file homefilename serverfilename :if-exists :overwrite)
  274.       ;; make sure the dates on both files are the same in case clocks are off on
  275.       ;; both machines. 
  276.       (set-file-write-date homefilename (file-write-date serverfilename)))
  277.     (return-from copy-to-server-and-update-logfile))
  278.   (update-log-file serverfilename))
  279.     
  280.  
  281. ;;; BUGS: doesn't check to see if the file already exists on the server
  282. (defun copy-new-file-to-server nil
  283.   (let (homefilename serverfilename)
  284.     (message-dialog "Please select a newly created file to copy to the server.")
  285.     (setq homefilename 
  286.           (catch-cancel (choose-file-dialog :directory *home-directory*
  287.                                 )))
  288.     (when (neq homefilename :cancel)
  289.       (setq homefilename (namestring homefilename))
  290.       (setq serverfilename (home-to-server-name homefilename))
  291.       (if (eq t (catch-cancel (y-or-n-dialog
  292.                                (concat "Can I store" homefilename " as " serverfilename "?"))))
  293.           (copy-to-server-and-update-logfile homefilename serverfilename)
  294.           (message-dialog "Aborting the copy ...")))))
  295.     
  296. (defun update-locked-file-list (file operation)
  297.   (let ((newpair (make-pair :filename file :person (username))))
  298.     (cond
  299.      ((eq operation :add) 
  300.       (pushnew newpair *locked-file-list*))
  301.    ((eq operation :delete) 
  302.     (setq *locked-file-list* 
  303.           (delete newpair *locked-file-list* :test #'equal)))
  304.    (t (error "illegal operation in update-locked-file-list")))
  305.   (save-locked-file-list)))
  306.  
  307. (defun update-log-file (filename)
  308.   (setq filename (namestring filename))
  309.   (let ((changes))
  310.     (with-open-file (stream *log-file* :direction :output :if-exists :append :if-does-not-exist :create)
  311.       (setq changes (catch-cancel 
  312.                      (get-string-from-user (concat "File " filename " has been copied to the server.  Describe your changes to the file here."))))
  313.       (format stream "~a \"~a\" ~a -- ~a~%" (machine-instance) filename (return-the-date) changes)
  314.       )))
  315.  
  316. (defun return-the-date nil
  317.   (multiple-value-bind  (second minute hour date month year 
  318.                                 day-of-week daylight-saving-timep time-zone)                        
  319.                         (get-decoded-time)
  320.     (declare (ignore second year day-of-week daylight-saving-timep time-zone))
  321.     (format nil "(~a:~2,'0d ~a/~2,'0d)" hour minute month date)))
  322.   
  323. (defun find-my-locked-files nil
  324.   (find-user-locked-files (username)))
  325.  
  326. (defun find-user-locked-files (user)
  327.   (mapcar 'get-filename
  328.           (remove user *locked-file-list* 
  329.                   :test #'(lambda (user y) (not (equal user (get-person y)))))))
  330.       
  331. (defun find-people-with-locked-files nil
  332.   (let (people)
  333.     (dolist (pair *locked-file-list*)
  334.       (pushnew (get-person pair) people :test #'equal))
  335.     people))
  336.  
  337.  
  338. (defun find-all-locked-files nil
  339.   (load-locked-file-list)
  340.   (format t "~%-------------------~%")
  341.   (dolist (person (find-people-with-locked-files))
  342.     (show-listener)
  343.     (format t "Locked files for ~a:~%" person)
  344.     (dolist (file (find-user-locked-files person))
  345.       (format t "   ~a~%" file))))
  346.  
  347. (defun show-listener nil
  348.   (window-select (find-window "Listener")))
  349.  
  350. (defun unlock-file-dont-copy nil
  351.   (unlock-project-file t))
  352.  
  353. ;;; copy a file and make sure the write dates are the same on both files
  354. (defun copy-file-and-set-write-date (fromfile tofile)
  355.   (copy-file fromfile tofile :if-exists :overwrite)
  356.   (set-file-write-date tofile (file-write-date fromfile)))
  357.  
  358. ;;;-----
  359. ;;; Copy files from logfile to local disk.  Remove duplicate names in logfile list of files.
  360. ;;; BUGS: doesn't check to see if local files are more recent than server files.
  361. (defun copy-logfiles-to-local-disk nil
  362.     (let (linelist selectlist tofile fromfilelist)
  363.       (with-open-file  (finput *log-file* :direction :input)
  364.         (setq linelist
  365.               (do* ((line (read-line finput nil :eof)(read-line finput nil :eof))
  366.                     (linelist)
  367.                     (pos))
  368.                    ((eq line :eof) linelist)
  369.                 (setq pos (position #\" line)) ;kludge for testing for a filename in line
  370.                 (if pos
  371.                   (push line linelist)))))
  372.       (setq selectlist
  373.             (catch-cancel 
  374.               (select-item-from-list linelist :selection-type :disjoint)))
  375.       (when (and selectlist (not (eq selectlist :cancel)))
  376.         (show-listener)
  377.         (setq fromfilelist
  378.               (mapcar #'(lambda (line) (read-from-string line nil nil :start (position #\" line)))
  379.                       selectlist))
  380.         (setq fromfilelist (remove-duplicates fromfilelist :test #'string-equal))
  381.         (dolist (fromfile fromfilelist)
  382.           (if (probe-file fromfile)
  383.             (progn
  384.               (setq tofile (server-to-home-name fromfile))
  385.               (format t "~%About to copy file ~a to ~a -- " fromfile tofile)
  386.               (copy-file-and-set-write-date fromfile tofile)
  387.               (format t "DONE"))
  388.             (format t "~%Did not copy file ~a because I could not find it." fromfile))))))
  389.     
  390.  
  391. #|
  392. ;;; copy one directory to another directory
  393.  
  394. ;;; verboseflag,if true, prints out a DOT when a file is read in
  395. ;;; purge, if true, deletes the destination directory
  396. (defun copy-directory (from to &optional (verboseflag t) (purge nil))
  397.   (setq from (namestring from)
  398.         to   (namestring to))
  399.   (if verboseflag (show-listener))
  400.   (if (and (probe-file from) (directoryp from) (directoryp to) (not (equal from to)))
  401.    (progn
  402.      (if (or purge (null (probe-file to)))
  403.        (create-file to :overwrite t))
  404.     (dolist (fromfile (list-of-files from))
  405.       (let* ((filename (file-namestring fromfile))
  406.              (tofile (merge-pathnames to filename))
  407.              (tofilepresent (probe-file tofile))
  408.              (fromfilewritedate (file-write-date fromfile))
  409.              (tofilewritedate (and tofilepresent (file-write-date tofile))))
  410.         ;;copy only if no file or new version of file
  411.         (if verboseflag (princ "."))
  412.         (cond ((or (null tofilepresent) 
  413.                 (< tofilewritedate fromfilewritedate))
  414.                (if tofilepresent (unlock-file tofile))
  415.                (copy-file fromfile tofile :if-exists :overwrite)
  416.                (set-file-write-date tofile fromfilewritedate))
  417.               ((and tofilewritedate (> tofilewritedate fromfilewritedate))
  418.                (format t "~%Warning...Your version of ~a is newer than the server's version."
  419.                        filename)))))
  420.     (do-directories-in-directory (dir from)
  421.       (let* ((newfromdir (pathname-directory dir))
  422.              (newpartdir (strip-left from newfromdir))
  423.              (newtodir (concat to newpartdir)))
  424.         (copy-directory newfromdir newtodir verboseflag purge))))
  425.    (format t "Did not copy ~a to ~a" from to)))
  426. |#
  427.       
  428. ;;; strip (length sub) characters from the left part of seq
  429. ;;; Used to strip off part of a directory from seq
  430. ;;; e.g. (strip-left "hd:" "hd:foo:") --> "foo:"
  431. (defun strip-left (sub seq)
  432.   (subseq seq (length sub)))
  433.  
  434. ;;; Return a list of files in directory "dir"
  435. ;;; function is probably WRONG
  436. (defun list-of-files (dir)
  437.   (directory (concat dir "*.*")))
  438.  
  439. ;;; ------------------------------------------------------------------------------
  440. (init-rcs)